perm filename TAK.LSP[E78,JMC]1 blob
sn#386664 filedate 1978-10-07 generic text, type T, neo UTF8
(DEFUN TAK (X Y Z)
(COND ((LESSP Y X)
(TAK (TAK (SUB1 X) Y Z)
(TAK (SUB1 Y) Z X)
(TAK (SUB1 Z) X Y)))
(T Y)))
(DEFUN CTAK (X Y Z)
(COND ((LESSP Y X)
(PLUS 1.
(CTAK (TAK (SUB1 X) Y Z)
(TAK (SUB1 Y) Z X)
(TAK (SUB1 Z) X Y))
(CTAK (SUB1 X) Y Z)
(CTAK (SUB1 Y) Z X)
(CTAK (SUB1 Z) X Y)))
(T 0.)))
(DEFUN RANGE (X Y Z) (DIFFERENCE (MAX X Y Z) (MIN X Y Z)))
(DEFUN CTAK2 (X Y Z)
(COND ((MEMCAR (LIST X Y Z) U) 0.)
((NOT (LESSP Y X))
(CAR (CONS 0. (SETQ U (CONS (CONS (LIST X Y Z) Y) U)))))
(T (PLUS 1.
(CTAK2 (SUB1 X) Y Z)
(CTAK2 (SUB1 Y) Z X)
(CTAK2 (SUB1 Z) X Y)
(CTAK2 (TAK2 (SUB1 X) Y Z)
(TAK2 (SUB1 Y) Z X)
(TAK2 (SUB1 Z) X Y))))))
(DEFUN TAK2 (X Y Z)
((LAMBDA (W)
(COND
((NOT (NULL W)) (CDR W))
(T (CDAR (SETQ U
(CONS (CONS (LIST X Y Z)
(COND ((NOT (LESSP Y X)) Y)
(T (TAK2 (TAK2 (SUB1 X)
Y
Z)
(TAK2 (SUB1 Y)
Z
X)
(TAK2 (SUB1 Z)
X
Y)))))
U))))))
(ASSOC (LIST X Y Z) U)))
(DEFUN CTAK1 (X Y Z) (CDR (CONS (SETQ U NIL) (CTAK2 X Y Z))))
(DEFUN MEMCAR (X U)
(AND (NOT (NULL U))
(OR (EQUAL X (CAAR U)) (MEMCAR X (CDR U)))))
(SETQ BASE (SETQ IBASE 10.))
(DEFUN DTAK (X Y Z)
(COND ((NOT (LESSP Y X)) 0.)
(T (ADD1 (MAX (DTAK (TAK (SUB1 X) Y Z)
(TAK (SUB1 Y) Z X)
(TAK (SUB1 Z) X Y))
(DTAK (SUB1 X) Y Z)
(DTAK (SUB1 Y) Z X)
(DTAK (SUB1 Z) X Y))))))
(DEFUN NTAK (X Y Z) (VTAK (LIST X Y Z)))
(DEFUN VTAK (U)
(COND ((NUMBERP U) U)
((NULL (CDR U)) (SUB1 (VTAK (CAR U))))
(T ((LAMBDA (X Y)
(COND ((NOT (LESSP Y X)) Y)
(T (VTAK (LIST (LIST (SUB1 X)
Y
(CADDR U))
(LIST (SUB1 Y)
(CADDR U)
X)
(LIST (LIST (CADDR U))
X
Y))))))
(VTAK (CAR U))
(VTAK (CADR U))))))
(DEFUN CVTAK (U)
(COND ((NUMBERP U) 0.)
((NULL (CDR U)) (CVTAK (CAR U)))
(T ((LAMBDA (X Y M N)
(COND ((NOT (LESSP Y X)) (PLUS 1. M N))
(T (PLUS 1.
M
N
(CVTAK (LIST (LIST (SUB1 X)
Y
(CADDR U))
(LIST (SUB1 Y)
(CADDR U)
X)
(LIST (LIST (CADDR U))
X
Y)))))))
(VTAK (CAR U))
(VTAK (CADR U))
(CVTAK (CAR U))
(CVTAK (CADR U))))))
(DEFUN VEVAL (E)
(COND ((ATOM E) E)
((EQ (CAR E) 'SUB1) (SUB1 (VEVAL (CADR E))))
((EQ (CAR E) 'IF)
(COND ((VEVAL (CADR E)) (VEVAL (CADDR E)))
(T (VEVAL (CADDDR E)))))
((EQ (CAR E) 'LESSEQ)
(NOT (LESSP (VEVAL (CADDR E)) (VEVAL (CADR E)))))
((ATOM (CAR E))
(VEVAL (CONS (GET (CAR E) 'EXPR) (CDR E))))
((EQ (CAAR E) 'LAMBDA)
(VEVAL (SUBLIS (PRUP (CADAR E) (CDR E)) (CADDAR E))))))
(DEFUN PRUP (U V)
(COND ((NULL U) NIL)
(T (CONS (CONS (CAR U) (CAR V))
(PRUP (CDR U) (CDR V))))))
(DEFUN TTAK (X Y Z)
(IF (LESSEQ X Y)
Y
(TTAK (TTAK (SUB1 X) Y Z)
(TTAK (SUB1 Y) Z X)
(TTAK (SUB1 Z) X Y))))
(DEFUN DTAK00 (M N)
(COND ((NOT (LESSP 0. M)) 0.)
((LESSP 1. N)
(PLUS M (QUOTIENT (TIMES N (SUB1 N)) 2.) -1.))
((LESSP -1. N) M)
((EQUAL N -1.)
(PLUS (QUOTIENT (TIMES (ADD1 M) (PLUS M 2.)) 2.) -1.))
(T (PLUS (QUOTIENT (TIMES (DIFFERENCE M N)
(ADD1 (DIFFERENCE M N)))
2.)
(MINUS M)
-1.))))
(defun tak0 (x y z) (cond ((not (lessp y x)) y) ((not (lessp z y)) z) (t x)))